home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / pp.el.z / pp.el
Encoding:
Text File  |  1998-05-21  |  6.5 KB  |  190 lines
  1. ;;; pp.el --- pretty printer for Emacs Lisp
  2.  
  3. ;; Copyright (C) 1989, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Randal Schwartz <merlyn@stonehenge.com>
  6. ;; Keywords: lisp, tools, language, extensions
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: FSF 19.34.
  26.  
  27. ;;; Code:
  28.  
  29. (defvar pp-escape-newlines t 
  30.   "*Value of print-escape-newlines used by pp-* functions.")
  31. ;; XEmacs changes
  32. (defvar pp-print-readably t
  33.   "*Value of `print-readably' used by pp-* functions.")
  34.  
  35. ;;;###autoload
  36. (defalias 'pprint 'pp)
  37.  
  38. (defun pp-to-string (object)
  39.   "Return a string containing the pretty-printed representation of OBJECT,
  40. any Lisp object.  Quoting characters are used when needed to make output
  41. that `read' can handle, whenever this is possible."
  42.   (save-excursion
  43.     (set-buffer (generate-new-buffer " pp-to-string"))
  44.     (unwind-protect
  45.     (progn
  46.       (lisp-mode-variables t)
  47.       (let ((print-escape-newlines pp-escape-newlines))
  48.         (prin1 object (current-buffer)))
  49.       (goto-char (point-min))
  50.       (while (not (eobp))
  51.         ;; (message "%06d" (- (point-max) (point)))
  52.         (cond
  53.          ((looking-at "\\s(\\|#\\s(")
  54.           (while (looking-at "\\s(\\|#\\s(")
  55.         (forward-char 1)))
  56.          ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
  57.            (> (match-beginning 1) 1)
  58.            (= ?\( (char-after (1- (match-beginning 1))))
  59.            ;; Make sure this is a two-element list.
  60.            (save-excursion
  61.              (goto-char (match-beginning 2))
  62.              (forward-sexp)
  63.              ;; (looking-at "[ \t]*\)")
  64.              ;; Avoid mucking with match-data; does this test work?
  65.              (char-equal ?\) (char-after (point)))))
  66.           ;; -1 gets the paren preceding the quote as well.
  67.           (delete-region (1- (match-beginning 1)) (match-end 1))
  68.           (insert "'")
  69.           (forward-sexp 1)
  70.           (if (looking-at "[ \t]*\)")
  71.           (delete-region (match-beginning 0) (match-end 0))
  72.         (error "Malformed quote"))
  73.           (backward-sexp 1))          
  74.          ((condition-case err-var
  75.           (prog1 t (down-list 1))
  76.         (error nil))
  77.           (backward-char 1)
  78.           (skip-chars-backward " \t")
  79.           (delete-region
  80.            (point)
  81.            (progn (skip-chars-forward " \t") (point)))
  82.           (if (not (char-equal ?' (char-after (1- (point)))))
  83.           (insert ?\n)))
  84.          ((condition-case err-var
  85.           (prog1 t (up-list 1))
  86.         (error nil))
  87.           (while (looking-at "\\s)")
  88.         (forward-char 1))
  89.           (skip-chars-backward " \t")
  90.           (delete-region
  91.            (point)
  92.            (progn (skip-chars-forward " \t") (point)))
  93.           (if (not (char-equal ?' (char-after (1- (point)))))
  94.           (insert ?\n)))
  95.          (t (goto-char (point-max)))))
  96.       (goto-char (point-min))
  97.       (indent-sexp)
  98.       (buffer-string))
  99.       (kill-buffer (current-buffer)))))
  100.  
  101. ;;;###autoload
  102. (defun pp (object &optional stream)
  103.   "Output the pretty-printed representation of OBJECT, any Lisp object.
  104. Quoting characters are printed when needed to make output that `read'
  105. can handle, whenever this is possible.
  106. Output stream is STREAM, or value of `standard-output' (which see)."
  107.   (princ (pp-to-string object) (or stream standard-output)))
  108.  
  109. ;;;###autoload
  110. (defun pp-eval-expression (expression)
  111.   "Evaluate EXPRESSION and pretty-print value into a new display buffer.
  112. If the pretty-printed value fits on one line, the message line is used
  113. instead.  Value is also consed on to front of variable  values 's
  114. value."
  115.   (interactive "xPp-eval: ")
  116.   (setq values (cons (eval expression) values))
  117.   (let* ((old-show-function temp-buffer-show-function)
  118.      ;; Use this function to display the buffer.
  119.      ;; This function either decides not to display it at all
  120.      ;; or displays it in the usual way.
  121.      (temp-buffer-show-function
  122.       (function
  123.        (lambda (buf)
  124.          (save-excursion
  125.            (set-buffer buf)
  126.            (goto-char (point-min))
  127.            (end-of-line 1)
  128.            (if (or (< (1+ (point)) (point-max))
  129.                (>= (- (point) (point-min)) (frame-width)))
  130.            (let ((temp-buffer-show-function old-show-function)
  131.              (old-selected (selected-window))
  132.              (window (display-buffer buf)))
  133.              (goto-char (point-min)) ; expected by some hooks ...
  134.              (make-frame-visible (window-frame window))
  135.              (unwind-protect
  136.              (progn
  137.                (select-window window)
  138.                (run-hooks 'temp-buffer-show-hook))
  139.                (select-window old-selected)))
  140.          (message "%s" (buffer-substring (point-min) (point)))
  141.          ))))))
  142.     (with-output-to-temp-buffer "*Pp Eval Output*"
  143.       (pp (car values)))
  144.     (save-excursion
  145.       (set-buffer "*Pp Eval Output*")
  146.       (let (emacs-lisp-mode-hook)
  147.     (emacs-lisp-mode)))))
  148.  
  149. ;;;###autoload
  150. (defun pp-eval-last-sexp (arg)
  151.   "Run `pp-eval-expression' on sexp before point (which see).
  152. With argument, pretty-print output into current buffer.
  153. Ignores leading comment characters."
  154.   (interactive "P")
  155.   (let ((stab (syntax-table)) (pt (point)) start exp)
  156.     (set-syntax-table emacs-lisp-mode-syntax-table)
  157.     (save-excursion
  158.       (forward-sexp -1)
  159.       ;; If first line is commented, ignore all leading comments:
  160.       (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;"))
  161.       (progn
  162.         (setq exp (buffer-substring (point) pt))
  163.         (while (string-match "\n[ \t]*;+" exp start)
  164.           (setq start (1+ (match-beginning 0))
  165.             exp (concat (substring exp 0 start)
  166.                 (substring exp (match-end 0)))))
  167.         (setq exp (read exp)))
  168.     (setq exp (read (current-buffer)))))
  169.     (set-syntax-table stab)
  170.     (if arg
  171.     (insert (pp-to-string (eval exp)))
  172.       (pp-eval-expression exp))))
  173.  
  174. ;;; Test cases for quote
  175. ;; (pp-eval-expression ''(quote quote))
  176. ;; (pp-eval-expression ''((quote a) (quote b)))
  177. ;; (pp-eval-expression ''('a 'b))    ; same as above
  178. ;; (pp-eval-expression ''((quote (quote quote)) (quote quote)))
  179. ;; These do not satisfy the quote test.
  180. ;; (pp-eval-expression ''quote)
  181. ;; (pp-eval-expression ''(quote))
  182. ;; (pp-eval-expression ''(quote . quote))
  183. ;; (pp-eval-expression ''(quote a b))
  184. ;; (pp-eval-expression ''(quotefoo))
  185. ;; (pp-eval-expression ''(a b))
  186.  
  187. (provide 'pp)                ; so (require 'pp) works
  188.  
  189. ;;; pp.el ends here.
  190.